home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / Mops 2.5 / Mops ƒ / Files < prev    next >
Encoding:
Text File  |  1994-10-31  |  14.0 KB  |  597 lines  |  [TEXT/MSET]
  1. \ Files  - file object and loader
  2.  
  3. cl1                        \ In case we're reloading
  4. ' cl1    -> abortVec
  5.     0    -> quitvec
  6.  
  7.  
  8.     0    value        SFDlgHook    \ Used in std file calls.  If non-zero,
  9.                                 \  points to the proc to be called while
  10.                                 \  the std file dialog is up.
  11.  
  12. -39        constant    EOF            \ EOF error return
  13. -43        constant    FNF            \ File not found ditto
  14.  
  15. -300     constant    FILE-MARK
  16. \ Marks the start of a loaded file - we plant some useful info there.
  17. \ We put the file name in the dic as if it's a definition name, but use
  18. \ file-mark as a "handler code".  Then after that we put the useful info.
  19. \ See extrasMod.
  20.  
  21. false    value    ASYNCH?
  22. false    value    ENDLOAD?
  23. false    value    LOG?
  24.  
  25.     0    value    OPEN_CNT
  26.     0    value    CLOSE_ERR_CNT
  27.  
  28. forward    CREATE_LOG
  29. forward    WRITE_LOG
  30.  
  31.     string    $LG1
  32.     string    $LG2
  33.  
  34.  
  35. : ASYNCH    true -> asynch?  ;
  36.  
  37. : IOWAIT    BEGIN  busy  0EXIT  pause  AGAIN   ;
  38.  
  39. : (ASY)        \ ( fcb -- )  Sets up for a low-level asynchronous read or write.
  40.     IOwait
  41.     -> busy  setCP  ;
  42.  
  43.  
  44. : VOLNAME?  {  str -- b } 
  45.     reset: str
  46.     58 chsearch: str
  47.     NIF  false  EXIT  THEN
  48.     lim: str  2 >=  ;
  49.  
  50.  
  51. forward  OPEN_WITH_PATHS
  52.  
  53. false    value    USE_PATHS?
  54.  
  55. : HFS?    $ 3f6 w@x  0>  ;
  56.  
  57. variable    MyDocName    28 allot
  58.  
  59. : MyDoc        \ ( -- addr len )
  60.     MyDocName  count  ;
  61.  
  62.  
  63. \ Standard file package support
  64.  
  65. : SFLOC  {  \ ht wd -- x:y }
  66.         \ Computes screen coordinates for top left of
  67.         \ SF dialog box.  Centers the box horizontally, and a bit above
  68.         \ the center vertically.
  69.     screenbits  -> ht  -> wd  2drop
  70.     ht 3 /  80 -  0 max  -> ht
  71.     wd 2/  170 -  0 max  -> wd
  72.     wd ht pack  ;
  73.  
  74.  
  75. :class     SFrec    super{ object } 
  76.  
  77. record
  78. {    int            Good
  79.     var            fType
  80.     int            vRefNum
  81.     int            Version
  82.  64    bytes        Filename        \ max size is 64
  83. }
  84. 4    ordered-col    fTypes            \ list of filetypes
  85.  
  86.  
  87. :m GetVRefNum:    get: vRefNum   ;m
  88. :m GetName:        addr: FileName   ;m
  89.  
  90. :m CALL:        \ ( routine# -- bool )  Calls a Standard File Package routine.
  91.     SFDlgHook  ^base  rot makeint  trap$ A9EA
  92.     get: good  ;m
  93.  
  94. :m STDGET:  ( type0 ...typeN ) {  #types -- bool } 
  95.     clear: fTypes  #types  0>
  96.     IF    #types 0  DO  add: fTypes  LOOP  THEN
  97.     SFloc  0 0  #types makeint  ixAddr: fTypes
  98.     2 call: self  ;m
  99.  
  100. :m STDPUT:  {  pAddr pLen nAddr nLen -- bool } 
  101.     pAddr pLen pad place
  102.     SFloc  pad  nAddr nLen  str255
  103.     1 call: self  ;m
  104.  
  105. ;class 
  106.  
  107.  
  108. objHandle    SFHDL
  109. objPtr        SFOBJ   class_is  SFrec
  110.  
  111.  
  112. \ DO_OPEN does the hard work for OPEN: file.  First, if either the DirID
  113. \ or the vol ref# is non-zero, we rashly assume we know which folder we
  114. \ want, and just do an open.  We also do that if we're not running under HFS.
  115. \ Then, if we get through to here, we need to look at the paths.  But wait!
  116. \ First, we check the default folder by just doing a plain open anyway!  If
  117. \ this fails with a "file not found", we call ?USE_PATHS which either does
  118. \ nothing (if we're not using a path designator file), or calls our PATHSMOD
  119. \ module to look at a PD file and try using those paths to find the wanted
  120. \ file.
  121.  
  122. : DO_OPEN  {  fcb mode -- rc } 
  123.     1 ++> open_cnt
  124.     ^base 48 + @                    \ DirID
  125.     ^base 22 + w@                    \ vol ref#
  126.     or  HFS? not  or                \ Either non-zero, or not HFS?
  127.     use_paths? not  or                \ Or paths disabled?
  128.     IF                                \ Yes: just do a normal open, and get out.
  129.         fcb mode (open)  EXIT
  130.     THEN
  131.                                     \ Maybe use HFS paths:
  132.     fcb mode (open) dup  0EXIT        \ Try default folder first
  133.                                     \ -- out if we found it
  134.     dup FNF <>  ?EXIT                \ If err wasn't FNF, get out
  135.     use_paths?  0EXIT                \ If paths disabled, out with FNF
  136.     drop  fcb mode open_with_paths  ;
  137.  
  138.  
  139. :class   FILE    super{ object }        general
  140.  
  141. 134    bytes        FCB            \ max parameter block (108 but for hgetvinfo)
  142.  
  143. record    FSSpec
  144. {    int            FSvRefNum
  145.     var            FSDirID
  146. 64    bytes        FileName
  147. }
  148.  
  149. :m CLEAR:        \ Clears the fcb, except for the filename.
  150.     ^base  18 erase  ^base 22 +  112 erase  ;m
  151.  
  152. :m SETNAMEPTR:    \ Sets filename pointer in the FCB.
  153.     ^base 140 +  ^base !fptr  ;m
  154.  
  155. :m NAME:        \ ( addr len -- )  Assigns file name to fcb.  Rest cleared.
  156.     setNamePtr: self  clear: self
  157.     ^base 140 +  >r                    \ Addr of filename (at end of fcb)
  158.     r@  64 blanks
  159.     ( addr len )  64 min  r>  >str255  drop  ;m
  160.  
  161. :m SETDIRID:    \ ( dirid -- )  Sets the DirID for the fcb
  162.     ^base 48 +  !  ;m
  163.  
  164. :m GETDIRID:    \ ( -- dirid )  Gets the DirID for the fcb
  165.     ^base 48 +  @  ;m
  166.  
  167. :m GETFREF:    \ ( -- fref )  Gets the file ref number.
  168.     ^base 24 +  w@  ;m
  169.  
  170. :m SETFREF:
  171.     ^base 24 +  w!  ;m
  172.  
  173. :m SETVREF:    \ ( vref# -- )  Sets the volRefNum for the fcb
  174.     ^base 22 +  w!  ;m
  175.  
  176. :m GETVREF:    \ ( -- vref# )  Gets the volRefNum for the fcb
  177.     ^base 22 +  w@  ;m
  178.  
  179.  
  180. :m CLOSE:    \ ( -- rc )   Needs to clear the file RefNum field,
  181.             \ as advised in Mac Tech note # 102.  In fact we clear
  182.             \ the whole fcb except the name and Vref, so we can reuse
  183.             \ the fcb for a subsequent operation without the extra info
  184.             \ left by read and write calls being interpreted as HFS info.
  185.             
  186.     ^base  (close)  getVref: self  clear: self  setVref: self
  187.     dup if  1 ++> close_err_cnt  else  -1 ++> open_cnt  then  ;m
  188.  
  189.  
  190. :m OPEN:    \ ( -- rc )
  191.     ^base 0 do_open  ;m
  192.  
  193. :m OPENREADONLY:
  194.     ^base 1 do_open  ;m
  195.  
  196.  
  197. :m NEW:    ^base  (make)  ;m
  198.  
  199. :m DELETE:    ^base (delete)  ;m
  200.  
  201. :m MOVETO:    \ ( byteoffset -- rc )  Positions relative to start of file
  202.     ^base 1 rot  (lseek)  ;m
  203.  
  204. :m POS:        \ ( -- byteoffset )
  205.     ^base  $ 2E +  @  ;m
  206.  
  207. :m SETEOF:    \ ( pos -- rc )  Sets end-of-file to absolute byte position
  208.     ^base 28 + !  ^base fdos$ a012  ;m
  209.  
  210. :m CREATE:  { \ volID -- } 
  211.             \ Opens and resets file or creates new if not present.
  212.     1 ++> open_cnt
  213.     ^base 0 (open)                \ Attempt to open - don't use paths
  214.     ?dup
  215.     IF    dup FNF =
  216.         IF    drop
  217.             new: self  ?dup NIF  ^base 0 (open)  THEN
  218.         THEN
  219.     ELSE
  220.         0 setEOF: self
  221.     THEN  ;m
  222.  
  223. :m LAST:        \ Positions to end of file.
  224.     big# moveto: self  drop  ;m
  225.  
  226. :m SIZE:        \ ( -- #bytes )  Returns logical eof for file currently open
  227.     ^base fdos$ a011  drop ^base 28 + @  ;m
  228.  
  229. :m BYTESREAD:    \ ( -- n )  Returns actual bytes read.
  230.     ^base 40 + @  ;m
  231.  
  232. :m FCB:  ( -- fcb )     ^base  ;m
  233.  
  234. :m RESULT:    \ ( -- rc )  Returns the last I/O result code.
  235.     ^base 16 + w@  ;m
  236.  
  237. :m MODE:        \ ( posMode -- )  Sets position mode
  238.     ^base 44 + w!  ;m
  239.  
  240.  
  241. :m WAIT:    \ ( -- rc )  Waits for asynch I/O on this file to finish.
  242.     BEGIN    ^base busy =
  243.         NIF   ^base 16 + w@x  EXIT  THEN
  244.         pause
  245.     AGAIN  ;m
  246.  
  247. :m ?WAIT:    \ ( rc1 -- rc2 )
  248.     asynch?
  249.     NIF        drop  wait: self
  250.     ELSE    false -> asynch?
  251.     THEN   ;m
  252.  
  253.  
  254. :m READ:        \ ( addr length -- rc )
  255.     0 mode: self ^base swap rot
  256.     ^base (asy)  (read)  ?wait: self  ;m
  257.  
  258. :m READLINE:    \ ( addr maxLen -- rc )  Reads terminating with CR
  259.     $ 0D80 mode: self  ^base  swap rot
  260.     ^base (asy)  (read)  ?wait: self  ;m
  261.  
  262. :m WRITE:        \ ( addr length -- rc )
  263.     ^base  swap rot
  264.     ^base (asy)  (write)  ?wait: self  ;m
  265.  
  266. :m SETNAME:        \ Gets name from input stream, and assigns to fcb.
  267.     & "  parse-word  name: self  ;m
  268.  
  269. :m GETNAME:        \ ( -- addr len )  Returns filename
  270.     addr: fileName  count  ;m
  271.  
  272. :m PRINT:        \ Prints the filename.
  273.     getName: self  type  ;m
  274.  
  275. :m GETFILEINFO:        \ ( -- rc )  Fills the parameter block with file info
  276.     ^base fdos$ A20C  ;m
  277.  
  278. :m SETFILEINFO:        \ ( -- rc )
  279.     ^base fdos$ A20D  ;m
  280.  
  281. :m SET:  { ftyp sig -- }            \ Sets file type, signature.
  282.     getDirID: self                    \ Save DirID
  283.     0 setDirID: self                \ and clear it (otherwise we'll get
  284.     getFileInfo: self  drop            \  "file not found")
  285.     sig  ^base  $ 24 +  !            \ Set signature
  286.     ftyp ^base  $ 20 +  !            \ Set type
  287.     0 setDirID: self
  288.     setFileInfo: self  drop
  289.     setDirID: self  ;m                \ Restore DirID
  290.  
  291.  
  292. :m DRIVE:    \ ( drive# -- )  set default drive to drive#
  293.     clear: self  setVRef: self  ^base fdos$ a015
  294.     ?error 165  ;m
  295.  
  296.  
  297. :m ACCEPT:  { addr len \ #chrs eof? -- #chrs eof? }     \ ACCEPTs from disk.
  298.     echo? IF  addr len erase  THEN        \ So the typed line is OK
  299.     addr len  readLine: self  -> eof?
  300.     bytesRead: self  eof? NIF  1-  THEN  -> #chrs
  301.     #chrs 0=  eof? and  IF  0  true  EXIT  THEN
  302.     addr #chrs +  c@  13 <>
  303.     IF                                \ Overlength line. Probably a comment.
  304.         BEGIN                        \ Gobble to CR or EOF
  305.             pad 100  readLine: self  -> eof?
  306.             eof?
  307.             IF        true
  308.             ELSE    pad  bytesRead: self  1-  +  c@ 13 =
  309.             THEN
  310.         UNTIL
  311.     THEN
  312.     #chrs -> len
  313.     echo?
  314.     IF    addr len type  cr  THEN
  315.     BEGIN                            \ Loop to convert tabs to blanks
  316.         addr len  9 scan  -> len  -> addr
  317.         len
  318.     WHILE
  319.         bl addr c!
  320.     REPEAT
  321.     #chrs  false   ;m
  322.  
  323.  
  324. :m RENAME: { taddr tlen -- rc } 
  325.     taddr tlen str255
  326.     ^base 28 + !  ^base fdos$ A00B  ;m
  327.  
  328.  
  329. :m GETTYPE:        \ ( -- type )
  330.     ^base 32 + @  ;m
  331.  
  332. :m FLUSHVOL:
  333.     ^base fdos$ A013  drop  ;m
  334.  
  335.  
  336. :m CLASSINIT:        clear: self  setNamePtr: self  ;m
  337.  
  338.  
  339. \ Standard file package calls.  If the value SFDlgHook is non-zero, we take it as the
  340. \ address of a dialog hook routine.
  341.  
  342. private
  343.  
  344. :m SFPCALL:        \ ( various get? -- b )  Calls a Standard File Package routine
  345.     classinit: self                        \ Make sure name pointer is right
  346.     ['] SFrec  newObj: SFhdl
  347.     obj: SFhdl  -> SFobj
  348.     IF    stdGet: SFobj  ELSE  stdPut: SFobj  THEN
  349.     IF    getVRefNum: SFobj  clear: self  setVref: self
  350.         getName: SFobj  count  addr: fileName  place
  351.         true
  352.     ELSE
  353.         false
  354.     THEN
  355.     release: SFhdl  ;m
  356.  
  357. public
  358.  
  359. :m STDGET:    \ ( type0 ...typeN #types -- bool )
  360.     true sfpCall: self  ;m
  361.  
  362. :m STDPUT:    \ ( pAddr pLen nAddr nLen -- bool )
  363.     false sfpCall: self  ;m
  364.  
  365. ;class 
  366.  
  367.  
  368. ' fFcb  set_to_class  file            \ Make fFcb a FILE objPtr
  369. 6    fFcb 8 -    w!
  370. ' file    fFcb 6 -    reloc!
  371. -6    fFcb 2 -    w!
  372.  
  373.  
  374. \ GetDirID returns the dirID of the last directory opened by a
  375. \ standard file call.
  376.  
  377. : GETDIRID    $ 398 @  ;
  378.  
  379.  
  380. \ FileList keeps a stack of open load files for nested loads.
  381.  
  382. objPtr    TOPFILE  class_is  file
  383.  
  384.  
  385. :class     FILELIST  super{ handleArray } 
  386.  
  387. :m DROP:
  388.     top: super                        \ Give error if empty
  389.     close: topFile  drop
  390.     drop: super
  391.     size: super  NIF  nilP  ELSE  obj: self  THEN
  392.     -> topFile
  393.     false -> endload?   ;m
  394.  
  395. :m PUSHNEW:        \ Adds a new file to the stack
  396.     ['] file  pushNewObj: self
  397.     false -> endload?
  398.     obj: self  -> topFile            \ Note this locks the file object
  399.                                     \ -- this is what we want.
  400.     0 setVref: topFile   ;m
  401.  
  402. :m CLEAR:    \ Removes all currently open files
  403.     false -> endload?
  404.     get: size  0EXIT
  405.     type# 180  ( File stack: )  cr  top: self
  406.     get: size  FOR
  407.         print: topFile  cr  drop: self
  408.     NEXT  ;m
  409.  
  410. ;class 
  411.  
  412.  
  413. 10    fileList    LOADFILE
  414.  
  415. 0    value        FILESTART_DP
  416. 0    value        CNT
  417. 0    value        SvLATEST
  418.  
  419.  
  420. : LOGIT
  421.     state  0EXIT                    \ Out if we're not compiling
  422.     here filestart_DP -  pad w!
  423.     pos: topFile  src-len -
  424.     pad 2+  !
  425.     pad 6  add: $lg1  ;
  426.  
  427.  
  428. 0    value    LASTPOS
  429.  
  430. : LOGCR
  431.     state  0EXIT
  432.     here lastPos <=  ?EXIT
  433.     here -> lastPos
  434.     pad 14 erase
  435.     here filestart_DP -  pad w!
  436.     latest svLatest <> IF  true pad 4+ c!  latest -> svLatest  THEN
  437.     pad 14  add: $lg2  ;
  438.  
  439.  
  440. : (FREFILL)        \ ( -- flag )  Does a refill from a file.
  441.     echo?
  442.     IF        ?pause
  443.     ELSE    cnt NIF  ?pause  20 -> cnt  else  1 --> cnt  THEN
  444.     THEN
  445.     log? IF  logCR  THEN
  446.     tib tibLen  accept: topfile  ( #chrs eof? ) -> endload?  #tib !
  447.     set_source  endload? 0=  ;
  448.  
  449. ' (Frefill) -> Frefill
  450.  
  451.  
  452. : (LD)
  453.     BEGIN
  454.         endload? IF  false -> endload?  EXIT  THEN
  455.         topfile -> source-ID  (Frefill)  IF  interpret  THEN
  456.         state not  echo? and  fWind? and  IF  ok  THEN
  457.     AGAIN  ;
  458.  
  459.  
  460. false    value    DO_CR?
  461.  
  462. : LOADTOP  {  \ svCurs svHere svDepth -- } 
  463.                             \ Interprets the file as a Mops source file.
  464.     openReadOnly: topfile
  465.     IF ( error )  getName: topfile  type  132 die  THEN
  466.     curs -> svCurs  -curs
  467.     cr
  468.     size: loadFile 2*  spaces  type# 173 ( Loading: ) 
  469.     getName: topfile  type
  470.     log? IF
  471.         create_log  ['] logit  -> logVec
  472.         0 -> svLatest
  473.     THEN
  474.     here -> svHere  depth -> svDepth
  475.     false -> endload?  false -> do_cr?
  476.     (ld)
  477.     ['] null  -> logvec
  478.     close: topfile  drop  log? IF write_log  THEN
  479.     do_cr?
  480.     IF  cr  size: loadFile 2*  ELSE  2  THEN  spaces  true -> do_cr?
  481.     here svHere -  ." Size: "  .
  482.     size: loadFile 1 <= IF  cr  THEN
  483.     depth svDepth <> IF  cr msg# 75  THEN
  484.                     \ Warning - stack depth different after load
  485.     svCurs -> curs  ;
  486.  
  487.  
  488. : ENDLOAD        true -> endload?  0 -> src-len  ;
  489.  
  490.  
  491. \ Nesting loader.  Usage: // filename
  492.  
  493. : //  {  \ svcurs addr len -- } 
  494.     pushNew: loadFile  setName: topFile
  495.     getName: topFile  mark_file
  496.     loadTop
  497.     drop: loadFile  ;
  498.  
  499.  
  500. \        ======= Module support ========
  501.  
  502. : NOMOD        -1 -> modbase  -1 -> MBcomp  0 -> CompMod  ;
  503.  
  504.  
  505. : LDFROMMOD {  newModbase \ svModbase svMBcomp -- } 
  506.         \ Load from a module.  We save and restore the current
  507.         \ modbase and MBcomp value, in case the load changes them.
  508.  
  509.     modbase -> svModbase  MBcomp -> svMBcomp
  510.     newModbase  dup  -> modbase  -> MBcomp
  511.     loadtop
  512.     svModbase -> modbase  svMBcomp -> MBcomp  ;
  513.  
  514.  
  515. \        ========== Save ==========
  516.  
  517. 'type COM    constant    SAVETYPE    \ file type = 'COM '
  518. 'type MOPS    constant    SAVESIG        \ Signature = 'MOPS'
  519.  
  520. : SAVE_THIS    \ ( -- addr len )  Defines what to save
  521.     ['] latest  here over -  ;
  522.  
  523.  
  524. \ PURGE gets rid of all loaded modules.  It is defined in the file Modules.
  525. \ SAVE needs to call it first, so that saved dic images don't appear to
  526. \ reference loaded modules which aren't really loaded.  So that we can call
  527. \ SAVE before Modules is loaded, we make PURGE a vector rather than a
  528. \ forward definition.
  529.  
  530. ' null    vect    PURGE
  531.  
  532.  
  533. : (SAVE)  {  \ savdp savlatest -- rc } 
  534.     create: ffcb  ?error 107
  535.     dp -> savdp  latest -> savlatest
  536.     save_this                        \ Call before we clobber DP
  537.     dp    ['] dp -  -> dp                \ Here we make DP and LATEST relative
  538.     latest    ['] dp -  -> latest        \  to DP so we can set them up when
  539.                                     \  saved image is read in
  540.     purge                            \ Purge modules so saved image has them all
  541.                                     \  unloaded
  542.     true -> savingDic?                \ Stops PAUSE from doing anything during
  543.                                     \  asynch I/O (could try to call a module,
  544.                                     \  but they're purged)
  545.     write: ffcb                        \ Leave return code on stack for caller
  546.     false -> savingDic?
  547.     savdp -> dp  savlatest -> latest    \ and DP and LATEST
  548.     savetype savesig set: ffcb
  549.     close: ffcb drop
  550. \    type# 101 ( Saved: )  getname: ffcb  type  cr  ;
  551. ;
  552.  
  553. : SAVE        \ Takes name from input stream.  Redefined later in Frontend.
  554.     setname: ffcb  (save)  ?error 105  ;
  555.  
  556.  
  557. \ CL2 is the next cleanup word - it cleans up all file stuff on abort,
  558. \ as well as whatever we were doing before (see CL1 in file Class).
  559.  
  560. : CL2
  561.     clear: loadfile  close: ffcb drop
  562.     nomod  release: $lg1  release: $lg2
  563.     ['] null  -> logvec  false -> endload?
  564.     false -> savingDic?
  565.     cl1  ;
  566.  
  567.  
  568. : FILINIT
  569.     ['] file  dup  ['] fFcb  4+  reloc!
  570.     fFcb 18 + @                    \ Name pointer - doc name may not be in fFcb
  571.     count  32 min  myDocName place
  572.     fFcb  make_obj
  573.     clear: loadfile  ;
  574.  
  575.  
  576. ' filinit    -> objinit
  577. ' cl2        -> abortvec
  578.  
  579. ' -echo  ' +echo            \ used when we execute x below
  580.  
  581. : -ECHO        false -> echo?  ;
  582. : +ECHO        true  -> echo?  ;
  583.  
  584. : x
  585.     execute            \ old +echo
  586.     -curs
  587.     ." saving interim.dic.  Now type" cr
  588.     ." // sys.ld" cr
  589.     ." to load the rest of the system."
  590.     execute            \ old -echo
  591.     +curs
  592. ;
  593.     
  594.  
  595. x  forget x
  596. save interim.dic
  597.